home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / gutil.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  15KB  |  638 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "segment.h"
  15. #include "gvars.h"
  16. #include "setp.h"
  17. #include "segmentp.h"
  18. #include "dbxp.h"
  19. #include "miscp.h"
  20. #include "gmiscp.h"
  21. #include "smiscp.h"
  22. #include "gutilp.h"
  23.  
  24. static short nature_root_type(Symbol);
  25.  
  26. extern Tuple segment_map_new(), segment_map_put();
  27. extern Segment segment_map_get();
  28. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  29.  
  30. /* create dummy entry for p (np is string with name of p)
  31.  * and call chaos if p is called
  32.  */
  33. #define undone(p, np) p() { chaos(strjoin(np, " not implemented")); }
  34.  
  35. int ada_bool(int x)                                                /*;ada_bool*/
  36. {
  37.     return (x != 0 ? 1 : 0) ;
  38. }
  39.  
  40. int assoc_symbol_exists(Symbol sym, int aname)            /*;assoc_symbol_exists*/
  41. {
  42.     /* return TRUE if assoc_symbol_get would succeed, FALSE otherwise */
  43.  
  44.     Tuple    tup;
  45.  
  46.     tup = ASSOCIATED_SYMBOLS(sym);
  47.     if (tup == (Tuple)0)
  48.         return FALSE;
  49.     else
  50.         return (tup[aname] != (char *)0);
  51. }
  52.  
  53. Symbol assoc_symbol_get(Symbol sym, int aname)            /*;assoc_symbol_get*/
  54. {
  55.     /* Enter asym as associated symbol of symbol sym. Aname is code
  56.      * definining position in tuple of associated symbols. The tuple
  57.      * is allocated if not already defined 
  58.      */
  59.  
  60.     Tuple    tup;
  61.  
  62.     tup = ASSOCIATED_SYMBOLS(sym);
  63.     if (tup == (Tuple)0)    /* if not allocated*/
  64.         chaos("assoc_symbol_get: tuple not allocated");
  65.     if (tup_size(tup)<aname)
  66.         chaos("associate_symbol_get: index out of range");
  67.     if (tup[aname] == (char *)0)
  68.         chaos("assoc_symbol_get: symbol not present");
  69.     return (Symbol) tup[aname];
  70. }
  71.  
  72. void assoc_symbol_put(Symbol sym, int aname, Symbol asym) /*;assoc_symbol_put*/
  73. {
  74.     /* Enter asym as associated symbol of symbol sym. Aname is code
  75.      * definining position in tuple of associated symbols. The tuple
  76.      * is allocated if not already defined 
  77.      */
  78.  
  79.     Tuple    tup;
  80.  
  81.     tup = ASSOCIATED_SYMBOLS(sym);
  82.     if (tup == (Tuple)0) { /* if need new tuple */
  83.         /* allocate three entries for now, should allocate proper count later */
  84.         tup = tup_new(3);
  85.         tup[1] = (char *)0;
  86.         tup[2] = (char *)0;
  87.         tup[3] = (char *)0;
  88.     }
  89.     if (tup_size(tup) < aname)
  90.         chaos("associate_symbol_put: index out of range");
  91.     tup[aname] = (char *) asym;
  92.     ASSOCIATED_SYMBOLS(sym) = tup;
  93. }
  94.  
  95. #ifdef DEBUG
  96. /* Calls to COMPILER_ERROR in SETL are translated to calls to
  97.  * commpiler_error in C. Where the SETL version builds up a string
  98.  * the C version adds a suffix to indicate argument type. For example
  99.  * compiler_error_n(s, n) to pass node. The case compiler_error_k is
  100.  * used to pass node for which the SETL version has
  101.  *    COMPILER_ERROR(s  + str N_KIND(node)
  102.  * This is written in C as
  103.  *    compiler_error_k(s, node)
  104.  * These are defined for DEBUG (base) version only. In the export version,
  105.  * they are redefined as macros (in ghdr.c) to call procedure
  106.  * exit_internal_error().
  107.  */
  108.  
  109. void compiler_error_k(char *s, Node node)                 /*;compiler_error_k*/
  110. {
  111.     printf("compiler error: %s\n", s); 
  112.     zpnod(node);
  113.     errors++;
  114.     chaos("compiler_error_k");
  115. }
  116.  
  117. void compiler_error_c(char *s, Tuple t)                    /*;compiler_error_c*/
  118. {
  119.     /* second arg is tuple corresponding to constraint*/
  120.     printf("compiler_error_c: %s\n", s);
  121.     errors++;
  122.     chaos("compile_error_c");
  123. }
  124.  
  125. void compiler_error_s(char *s, Symbol sym)                /*;compiler_error_s*/
  126. {
  127.     /* second argument is symbol */
  128.     printf("compiler_error_s: %s\n", s); 
  129.     zpsym(sym);
  130.     errors++;
  131.     chaos("compiler_error_s");
  132. }
  133. #endif
  134.  
  135. Tuple discriminant_list_get(Symbol record)            /*;discriminant_list_get*/
  136. {
  137.     /* DISCRIMINANT_LIST(record); SIGNATURE(root_type(record))(2)  */
  138.     Tuple    tup;
  139.     tup = SIGNATURE(root_type(record));
  140.     return (Tuple) tup[3];
  141. }
  142.  
  143. /* The SETL map EMAP is accessed in C by the following procedures:
  144.  *     emap_get(symbol)
  145.  *    emap_put(symbol, value)
  146.  *  Note that emap_get returns TRUE if EMAP defined for the argument,
  147.  *  and sets EMAP_VALUE to the value, or returns FALSE if the value
  148.  *  not defined.
  149.  *  The SETL sequence
  150.  *    EMAP(s) = OM;
  151.  *  is translated as
  152.  *    emap_undef(s);
  153.  */
  154.  
  155. int emap_get(Symbol sym)                                    /*;emap_get*/
  156. {
  157.     int    i, n;
  158.     n = tup_size(EMAP);
  159.     for (i = 1; i <= n; i += 2) {
  160.         if (EMAP[i] == (char *) sym) {
  161.             EMAP_VALUE = (Tuple) EMAP[i+1];
  162.             return TRUE;
  163.         }
  164.     }
  165.     return FALSE;
  166. }
  167.  
  168. void emap_put(Symbol sym, char *val)            /*;emap_put*/
  169. {
  170.     int        i, n;
  171.     n = tup_size(EMAP);
  172.     for (i = 1; i <= n; i += 2) {
  173.         if (EMAP[i] == (char *) sym) {
  174.             EMAP[i+1] = val;
  175.             return;
  176.         }
  177.     }
  178.     EMAP = tup_with(EMAP, (char *) sym); /* add as new entry */
  179.     EMAP = tup_with(EMAP, (char *) val); /* add new value */
  180. }
  181.  
  182. void emap_undef(Symbol s)                                    /*;emap_undef*/
  183. {
  184.     int    i, n, j;
  185.  
  186.     n = tup_size(EMAP);
  187.     for (i = 1; i <= n; i += 2) {
  188.         if (EMAP[i] == (char *) s) {
  189.             /* if defined here, move down later entries*/
  190.             for (j = i; j < n - 1; j ++) {
  191.                 EMAP[j] = EMAP[j+2];
  192.             }
  193.         }
  194.     }
  195. }
  196.  
  197. void generate_object(Symbol s)                            /*;generate_object*/
  198. {
  199.     if (!tup_mem((char *)s, GENERATED_OBJECTS))
  200.         GENERATED_OBJECTS = tup_with(GENERATED_OBJECTS, (char *) s);
  201. }
  202.  
  203. Tuple get_constraint(Symbol type_name)                    /*;get_constraint*/
  204. {
  205.     /* constraints on access types are now also tuples in the C version.*/
  206.     if (is_array(type_name) || NATURE(base_type(type_name)) == na_subtype) {
  207.         Tuple tup; /* TBSL: make this a static constant */
  208.         tup = tup_new(5);
  209.         tup[1] = (char *)co_index;
  210.         tup[2] = (char *)OPT_NODE;
  211.         tup[3] = (char *)OPT_NODE;
  212.         return tup;
  213.     }
  214.     else {
  215.         return SIGNATURE(type_name);
  216.     }
  217. }
  218.  
  219. Symbol get_type(Node node)                                        /*;get_type*/
  220. {
  221.     int    nk;
  222.     Symbol    sym;
  223.  
  224.     nk = N_KIND(node);
  225.     if (nk == as_simple_name || nk == as_subtype_indic) {
  226.         sym = N_UNQ(node);
  227.         if (sym == (Symbol)0) {
  228. #ifdef DEBUG
  229.             zpnod(node);
  230. #endif
  231.             chaos("get_type: N_UNQ not defined for node");
  232.         }
  233.         else {
  234.             sym =  TYPE_OF(sym);
  235.         }
  236.     }
  237.     else {
  238.         sym = N_TYPE(node);
  239.     }
  240.     return sym;
  241. }
  242.  
  243. int has_discriminant(Symbol typ)                        /*;has_discriminant*/
  244. {
  245.     /* Note that has_discriminant is adasem macro that is NOT same as
  246.      * discriminant_list macro defined in adagen. Calls of the latter must
  247.      * be translated as discriminant_list_get.
  248.      */
  249.     Tuple    tup;
  250.     tup = discriminant_list_get(typ);
  251.     if (tup == (Tuple)0) return FALSE;
  252.     return tup_size(tup) > 0;
  253. }
  254.  
  255. int has_static_size(Symbol typ)                            /*;has_static_size*/
  256. {
  257.     return size_of(typ) >= 0;
  258. }
  259.  
  260. int is_access_type(Symbol typ)                            /*;is_access_type*/
  261. {
  262.     return nature_root_type(typ) == na_access;
  263. }
  264.  
  265. int is_aggregate(Node node)                                    /*;is_aggregate*/
  266. {
  267.     register int    nk;
  268.     nk = N_KIND(node);
  269.     return nk == as_array_aggregate || nk == as_array_ivalue
  270.       ||  nk == as_record_aggregate || nk == as_record_ivalue;
  271. }
  272.  
  273. int is_array_type(Symbol typ)                            /*;is_array_type*/
  274. {
  275.     return nature_root_type(typ) == na_array;
  276. }
  277.  
  278. int is_entry_type(Symbol typ)                                /*;is_entry_type*/
  279. {
  280.     return NATURE(typ) == na_entry_former;
  281. }
  282.  
  283. int is_enumeration_type(Symbol typ)                        /*;is_enumeration_type*/
  284. {
  285.     return NATURE(root_type(typ)) == na_enum;
  286. }
  287.  
  288. int is_float_type(Symbol typ)                                /*;is_float_type*/
  289. {
  290.     Tuple    tup;
  291.     tup = SIGNATURE(typ);
  292.     return (int)tup[1] == co_digits;
  293. }
  294.  
  295. int is_formal_parameter(Symbol sym)                    /*;is_formal_parameter*/
  296. {
  297.     register int    na;
  298.     int                 s_n, found;
  299.     Symbol              same_sym, sym_scope;
  300.     Fortup              ft1;
  301.  
  302.     na = NATURE(sym);
  303.     return ((na == na_in || na == na_inout || na == na_out)
  304.             && assoc_symbol_exists(sym,FORMAL_TEMPLATE) );
  305. }
  306.  
  307. int is_global(Symbol sym)                                        /*;is_global*/
  308. {
  309.     return sym->s_segment != -1;
  310. }
  311.  
  312. int is_integer_type(Symbol typ)                                /*;is_integer_type*/
  313. {
  314.     return root_type(typ) == symbol_integer;
  315. }
  316.  
  317. int is_ivalue(Node node)                                        /*;is_ivalue*/
  318. {
  319.     int    nk = N_KIND(node);
  320.     return nk == as_ivalue || nk == as_int_literal || nk == as_string_ivalue
  321.       || nk == as_real_literal || nk == as_array_ivalue
  322.       || nk == as_record_ivalue;
  323. }
  324.  
  325. int is_object(Node node)                                        /*;is_object*/
  326. {
  327.     int    nk = N_KIND(node);
  328.     return nk == as_simple_name || nk == as_null || nk == as_name
  329.       || nk == as_slice || nk == as_index || nk == as_selector;
  330. }
  331.  
  332. int is_record_subtype(Symbol typ)                        /*;is_record_subtype*/
  333. {
  334.     return is_record_type(typ) && NATURE(typ) == na_subtype;
  335. }
  336.  
  337. int is_record_type(Symbol typ)                                /*;is_record_type*/
  338. {
  339.     return nature_root_type(typ) == na_record;
  340. }
  341.  
  342. int is_renaming(Symbol sym)                                    /*;is_renaming*/
  343. {
  344.     return ALIAS(sym) != (Symbol)0;
  345. }
  346.  
  347. int is_simple_name(Node node)                                /*;is_simple_name*/
  348. {
  349.     int nk = N_KIND(node);
  350.     return nk == as_simple_name || nk == as_null || nk == as_name;
  351. }
  352.  
  353. int is_simple_type(Symbol typ)                                /*;is_simple_type*/
  354. {
  355.     return nature_root_type(typ) != na_array
  356.       && nature_root_type(typ) != na_record;
  357. }
  358.  
  359. int is_static_type(Symbol typ)                                /*;is_static_type*/
  360. {
  361.     return is_global(typ) && has_static_size(typ);
  362. }
  363.  
  364. int local_reference_map_defined(Symbol sym)        /*;local_reference_map_defined*/
  365. {
  366.     /* return TRUE if local_reference_map defined for sym, else FALSE */
  367.     int        i, n;
  368.     n = tup_size(LOCAL_REFERENCE_MAP);
  369.     for (i = 1; i <= n; i += 2) {
  370.         if (LOCAL_REFERENCE_MAP[i] == (char *) sym)
  371.             return TRUE;
  372.     }
  373.     return FALSE;
  374. }
  375.  
  376. Tuple local_reference_map_new()                    /*;local_reference_map_new*/
  377. {
  378.     return tup_new(0);
  379. }
  380.  
  381. unsigned int local_reference_map_get(Symbol sym)    /*;local_reference_map_get*/
  382. {
  383.     int        i, n;
  384.     n = tup_size(LOCAL_REFERENCE_MAP);
  385.     for (i = 1; i <= n; i += 2) {
  386.         if (LOCAL_REFERENCE_MAP[i] == (char *) sym)
  387.             return (unsigned int) LOCAL_REFERENCE_MAP[i+1];
  388.     }
  389.     chaos("local_reference_map_get unable to find value "); 
  390.     return 0;
  391. }
  392.  
  393. void local_reference_map_put(Symbol sym, int off)    /*;local_reference_map_put*/
  394. {
  395.     int        i, n;
  396.     n = tup_size(LOCAL_REFERENCE_MAP);
  397.     for (i = 1; i <= n; i += 2) {
  398.         if (LOCAL_REFERENCE_MAP[i] == (char *)sym) {
  399.             LOCAL_REFERENCE_MAP[i+1] = (char *) off;
  400.             return;
  401.         }
  402.     }
  403.     LOCAL_REFERENCE_MAP = tup_exp(LOCAL_REFERENCE_MAP, n+2);
  404.     LOCAL_REFERENCE_MAP[n+1] = (char *) sym;
  405.     LOCAL_REFERENCE_MAP[n+2] = (char *) off;
  406. }
  407.  
  408. int mu_size(int mutyp)                                            /*;mu_size*/
  409. {
  410.     /* This procedure returns the number of storage units required for
  411.      * the memory type given by mutyp, one of the mu_ codes.
  412.      */
  413. #ifdef WORDSIZE16
  414.     switch (mutyp) {
  415.     case(mu_byte):
  416.     case(mu_word):
  417.         return 1;
  418.     case(mu_addr):
  419.     case(mu_long):
  420.     case(mu_xlng): /* check that mu_xlng value right */
  421.         return 2; /* check desired size */
  422.     case(mu_dble):
  423.         return 4;
  424.     default:
  425.         chaos("mu_size: bad argument"); 
  426.         return 0;
  427.     }
  428. #else
  429.     switch (mutyp) {
  430.     case(mu_byte):
  431.     case(mu_word):
  432.     case(mu_long):
  433.         return 1;
  434.     case(mu_addr):
  435.     case(mu_xlng): /* check that mu_xlng value right */
  436.         return 2; /* check desired size */
  437.     case(mu_dble):
  438.         return 4;
  439.     default:
  440.         chaos("mu_size: bad argument"); 
  441.         return 0;
  442.     }
  443. #endif
  444. }
  445.  
  446. int su_size(int ktyp)                                                /*;su_size*/
  447. {
  448.     /* This procedure returns the number of storage units required for
  449.      * the memory type given by ktyp, one of the TK_ codes.
  450.      */
  451. #ifdef WORDSIZE16
  452.     switch (ktyp) {
  453.     case TK_BYTE:
  454.     case TK_WORD: 
  455.         return 1;
  456.     case TK_LONG:
  457.     case TK_XLNG:
  458.     case TK_ADDR: 
  459.         return 2;
  460.     case TK_DBLE: 
  461.         return 4;
  462.     default:
  463.         chaos("su_size: bad argument");
  464.         return 0; /* for the sake of lint */
  465.     }
  466. #else
  467.     switch (ktyp) {
  468.     case TK_BYTE:
  469.     case TK_LONG:
  470.     case TK_WORD: 
  471.         return 1;
  472.     case TK_XLNG:
  473.     case TK_ADDR: 
  474.         return 2;
  475.     case TK_DBLE: 
  476.         return 4;/* dble is double address, not C double */
  477.     default:
  478.         chaos("su_size: bad argument");
  479.         return 0; /* for the sake of lint */
  480.     }
  481. #endif
  482. }
  483.  
  484. void next_local_reference(Symbol name)                /*;next_local_reference*/
  485. {
  486.     LAST_OFFSET            -= mu_size(mu_addr);
  487.     local_reference_map_put(name, LAST_OFFSET);
  488. }
  489.  
  490. void next_global_reference_def(Symbol name)        /*;next_global_reference_def*/
  491. {
  492.     /* begin definition of initial data for specified symbol at end
  493.      * of currrent data segment.
  494.      */
  495.  
  496. #ifdef MACHINE_CODE
  497.     Gref    gref;
  498. #endif
  499.     S_SEGMENT(name) = CURRENT_DATA_SEGMENT;
  500.     S_OFFSET(name) = DATA_SEGMENT->seg_maxpos;
  501.     /*REFERENCE_MAP(name) = [CURRENT_DATA_SEGMENT, #DATA_SEGMENT+1];*/
  502. #ifdef MACHINE_CODE
  503.     if (list_code) { /* save for printout */
  504.         gref = (Gref) emalloct(sizeof(Gref_s), "gref");
  505.         gref->gref_sym = name;
  506.         gref->gref_seg = CURRENT_DATA_SEGMENT;
  507.         gref->gref_off = DATA_SEGMENT->seg_maxpos;
  508.         /*n = tup_size(global_reference_tuple);*/
  509.         global_reference_tuple = tup_with(global_reference_tuple, (char *)gref);
  510.     }
  511. #endif
  512. }
  513.  
  514. void next_global_reference_r(Symbol sym, int seg, unsigned int off)
  515.                                                     /*;next_global_reference_r*/
  516. {
  517.     /* need to extend DATA_SEGMENT with seg and off */
  518.  
  519.     next_global_reference_def(sym);
  520.     segment_put_word(DATA_SEGMENT, seg);
  521.     segment_put_word(DATA_SEGMENT, off);
  522.  
  523. }
  524.  
  525. void next_global_reference_segment(Symbol sym, Segment seg)
  526.                                             /*;next_global_reference_segment*/
  527. {
  528.     /* install segment seg as next global reference */
  529.  
  530.     next_global_reference_def(sym);
  531.     segment_append(DATA_SEGMENT, seg);
  532. }
  533.  
  534. void next_global_reference_template(Symbol sym, Segment seg)
  535.                                             /*;next_global_reference_template*/
  536. {
  537.     next_global_reference_segment(sym, seg);
  538. }
  539.  
  540. void next_global_reference_z(Symbol sym)            /*;next_global_reference_z*/
  541. {
  542.     /* This corresponds to SETL case next_global_reference(sym, [0, 0]);]
  543.      * which we translate to next_global_reference_r for now, though
  544.      * the correctness of this translation needs to be checked
  545.      */
  546.  
  547.     next_global_reference_def(sym);
  548.     segment_put_word(DATA_SEGMENT, 0);
  549.     segment_put_word(DATA_SEGMENT, 0);
  550. }
  551.  
  552. void next_global_reference_word(Symbol sym, int w)
  553.                                                 /*;next_global_reference_word*/
  554. {
  555.     /* This corresponds to SETL case of adding value [n] where n is assumed
  556.      * to take only a word.
  557.      */
  558.  
  559.     next_global_reference_def(sym);
  560.     segment_put_word(DATA_SEGMENT, w);
  561. }
  562.  
  563. Symbol new_unique_name(char *s)                            /*;new_unique_name*/
  564. {
  565.     /* TBSL: see if this is right translation?  ds  3-12-85 */
  566.     /* If list_code on, then create ORIG_NAME from argument by appending
  567.      * sequence number
  568.      */
  569. #ifdef MACHINE_CODE
  570.     Symbol    sym;
  571.     char    seq[10];
  572.  
  573.     sym = sym_new(na_void);
  574.     sprintf(seq, "#%d", S_SEQ(sym));
  575.     ORIG_NAME(sym) = (s != (char *)0) ? strjoin(s, seq) : strjoin(seq, "");
  576.     return sym;
  577. #else
  578.     return sym_new(na_void);
  579. #endif
  580. }
  581.  
  582. static short nature_root_type(Symbol typ)                /*;nature_root_type*/
  583. {
  584.     Symbol sym;
  585.  
  586.     if (typ == (Symbol)0)
  587.         chaos("gutil.c : nature_root_type argument null");
  588.  
  589.     sym = root_type(typ);
  590.  
  591.     if (sym == (Symbol)0)
  592.         chaos("gutil.c : nature_root_type, root_type of arg null");
  593.  
  594.     return NATURE(sym);
  595. }
  596.  
  597. Segment segment_map_get(Tuple tup, int sn)                /*;segment_map_get*/
  598. {
  599.     /* tup is segment map, sn is segment number */
  600.  
  601.     int        i, n;
  602.  
  603.     n = tup_size(tup);
  604.     for (i = 1; i<n; i += 2) {
  605.         if ((int) tup[i] == sn)
  606.             return (Segment) tup[i+1];
  607.     }
  608.     return (Segment) 0;
  609. }
  610.  
  611. Tuple segment_map_put(Tuple tup, int sn, Segment seg)        /*;segment_map_put*/
  612. {
  613.     /* tup is segment map, sn is segment number */
  614.  
  615.     int        i, n;
  616.  
  617.     n = tup_size(tup);
  618.     for (i = 1; i<n; i += 2) {
  619.         if ((int) tup[i] == sn) {
  620.             tup[i+1] = (char *) seg;
  621.             return tup;
  622.         }
  623.     }
  624.     /* here if no entry, make new one, possible reallocating tuple */
  625.     tup = tup_exp(tup, n+2);
  626.     tup[n+1] = (char *) sn;
  627.     tup[n+2] = (char *) seg;
  628.     return tup;
  629. }
  630.  
  631. Const    small_of(Symbol typ)                                    /*;small_of*/
  632. {
  633.     /* It returns const, that should always be rational and so
  634.      * perhaps should insert check here that this holds    ds 7-1-85*/
  635.     Tuple tup = SIGNATURE(typ);
  636.     return get_ivalue((Node)tup[5]);
  637. }
  638.